home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
095
/
rbbssrc2.arc
/
RBBSSUB1.BAS
< prev
next >
Wrap
BASIC Source File
|
1987-03-15
|
82KB
|
2,210 lines
' $linesize:132
' $title: 'RBBS-SUB1.BAS CPC15-1A, Copyright 1986, 87 by D. Thomas Mack'
' Copyright 1987 by D. Thomas Mack, all rights reserved.
' Name ...............: RBBSSUB1.BAS
' Written by .........: D. Thomas Mack
' First Released .....: June 29, 1986
' Subsequent Releases.: September 28, 1986, March 15, 1987
' Copyright ..........: 1986, 1987
' Purpose.............: The Remote Bulletin Board System for the IBM PC,
' RBBS-PC.BAS utilizes a lot of common subroutines.
' Those that require error trapping are incorporated
' within RBBSSUB1.BAS as separately callable subroutines
' in order to free up as much code as possible within
' the 64K code segment used by RBBS-PC.BAS.
' Parameters..........: Most parameters are passed via a COMMON statement.
'
' Subroutine Line Function of Subroutine
' Name Number
' ANSWERIT 201 Answer the telephone when it rings
' ASKUSERS 64005 Ask users questions based on a script and save answers
' BAUD450 5507 Allow 300 baud callers to bump up to 450 baud
' FINDFREE 52000 Find amount of space on the upload disk drive
' FINDIT 20221 Find if a file exists on a device
' FINDUSER 12610 Find a user in the USERS file
' LINEEDIT 3700 Edit a line while minimizing string space consumption
' OPENRSEQ 1479 Open a sequential file (number 2) for random I/O
' OPENFMS 58190 Open the upload management system directory
' OPENUSER 9400 Open the USER file (number 5)
' OPENWORK 58000 Open RBBS-PC's work file (number 2)
' PASSWORD 667 Verify User & Message Passwords
' PRINTIT 13674 Print line on the local PC running RBBS-PC printer
' READDEF 117 Open and read RBBS-PC's ".DEF" file of parameters
' SENDNAME 20295 Send filename via EXEC-PC protocol during autodownload
' TESTUSER 20310 Check if user's software can do auto downloading
' TGET 1500 Read a line from the communications port
' TPUT 1400 Write a line to the communications port
' UPDATEC 43050 Update the caller's file with elasped session time
' UPDTCALR 13665 Update to the caller's file
'
' $INCLUDE: 'RBBS-VAR.BAS'
'
' $SUBTITLE: 'READDEF - subroutine to read RBBS-PC.DEF file'
' $PAGE
'
' SUBROUTINE NAME -- READDEF
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CONFIG.FILENAME$ NAME OF RBBS-PC.DEF FILE
' SUBROUTINE.PARAMETER = -62 ONLY READ THE .DEF FILE
'
' OUTPUT PARAMETERS -- ALL THE RBBS-PC.DEF PARAMETERS
'
' SUBROUTINE PURPOSE -- TO READ THE PARAMETERS FROM THE RBBS-PC.DEF FILE
SUB READDEF STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * OPEN AND READ RBBS-PC CONFIGURATION DEFINITIONS *
' *****************************************************************************
'
117 CLOSE 2
OPEN "I",2,CONFIG.FILENAME$
INPUT #2,DOWNLOAD.DRIVES$, _
SYSOP.PASSWORD.1$, _
SYSOP.PASSWORD.2$, _
SYSOP.FIRST.NAME$, _
SYSOP.LAST.NAME$, _
REQUIRED.RINGS, _
START.OFFICE.HOURS, _
END.OFFICE.HOURS, _
MINUTES.PER.SESSION!, _
DF, _
DF, _
UPLOAD.DIRECTORY$, _
EXPERT.USER, _
ACTIVE.BULLETINS, _
PROMPT.BELL, _
DF, _
DF, _
MENU$(1), _
MENU$(2), _
MENU$(3), _
MENU$(4), _
MENU$(5), _
CONFERENCE.MENU$, _
DF, _
WELCOME.INTERRUPTABLE, _
REMIND.FILE.TRANSFERS, _
PAGE.LENGTH, _
MAX.MESSAGE.LINES, _
DOORS.AVAILABLE, _
DF$
INPUT #2,MAIN.MESSAGE.FILE$, _
MAIN.MESSAGE.BACKUP$, _
CALLERS.FILE$, _
COMMENTS.FILE$, _
MAIN.USER.FILE$, _
WELCOME.FILE$, _
NEWUSER.FILE$, _
DIRECTORY.EXTENTION$, _
COM.PORT$, _
BULLETINS.OPTIONAL, _
MODEM.INIT.COMMAND$, _
DF$, _
DF, _
FG, _
BG, _
BORDER, _
RBBS.BAT$, _
RCTTY.BAT$
DOS.VERSION = 2
INPUT #2,OMIT.MAIN.DIRECTORY$, _
DUMMY$, _
HELP$(3), _
HELP$(4), _
HELP$(7), _
HELP$(9), _
BULLETIN.MENU$, _
BULLETIN.PREFIX$, _
DF$, _
MESSAGE.REMINDER, _
REQUIRE.NON.ASCII, _
DOORS.SECURITY.LEVEL, _
MAXIMUM.NUMBER.OF.NODES, _
NETWORK.TYPE, _
RECYCLE.TO.DOS, _
DF, _
DF, _
TRASHCAN.FILE$
INPUT #2,MINIMUM.LOGON.SECURITY, _
DEFAULT.SECURITY.LEVEL, _
SYSOP.SECURITY.LEVEL, _
FILESEC.FILE$, _
SYSOP.MENU.SECURITY.LEVEL, _
LOCAL.PASSWORD$, _
MAXIMUM.VIOLATIONS, _
OPT.SEC(40), _ ' SECURITY FOR SYSOP COMMANDS 1
OPT.SEC(41), _
OPT.SEC(42), _
OPT.SEC(43), _
OPT.SEC(44), _
OPT.SEC(45), _
OPT.SEC(46), _ ' SYSOP 7
PASSWORDS.FILE$, _
MAXIMUM.PASSWORD.CHANGES, _
MINIMUM.SECURITY.FOR.TEMP.PASSWORD, _
OVERWRITE.SECURITY.LEVEL, _
DOORS.TERMINAL.TYPE, _
LIMIT.DAILY.TIME
INPUT #2,OPT.SEC(1), _ ' SECURITY FOR MAIN MENU COMMANDS 1
OPT.SEC(2), _
OPT.SEC(3), _
OPT.SEC(4), _
OPT.SEC(5), _
OPT.SEC(6), _
OPT.SEC(7), _
OPT.SEC(8), _
OPT.SEC(9), _
OPT.SEC(10), _
OPT.SEC(11), _
OPT.SEC(12), _
OPT.SEC(13), _
OPT.SEC(14), _
OPT.SEC(15), _
OPT.SEC(16), _
OPT.SEC(17), _ ' MAIN COMMAND 17
DEFAULT.MACHINE.TYPE$, _
WAIT.BEFORE.DISCONNECT
INPUT #2,OPT.SEC(18), _ ' Security for FILE COMMANDS 1
OPT.SEC(19), _
OPT.SEC(20), _
OPT.SEC(21), _
OPT.SEC(22), _
OPT.SEC(23), _
OPT.SEC(24), _ ' FILE COMMAND 7
OPT.SEC(25), _ ' SECURITY FOR UTILITY COMMANDS 1
OPT.SEC(26), _
OPT.SEC(27), _
OPT.SEC(28), _
OPT.SEC(29), _
OPT.SEC(30), _
OPT.SEC(31), _
OPT.SEC(32), _
OPT.SEC(33), _
OPT.SEC(34), _
OPT.SEC(35), _ ' UTIL COMMAND 11
OPT.SEC(36), _ ' SECURITY FOR GLOBAL COMMANDS 1
OPT.SEC(37), _
OPT.SEC(38), _
OPT.SEC(39), _ ' GLOBAL 4
UPLOAD.TIME.FACTOR!, _
COMPUTER.TYPE, _
REMIND.PROFILE, _
RBBS.NAME$, _
COMMANDS.BETWEEN.RINGS, _
MNP.SUPPORT, _
PAGING.PRINTER.SUPPORT$, _
MODEM.INIT.BAUD$
118 INPUT #2, TURN.PRINTER.OFF,_ ' Turn printer off after each recycle
DIRECTORY.PATH$, _ ' Where dir files are stored
MIN.SEC.TO.VIEW, _
LIMIT.SEARCH.TO.FMS, _
DEFAULT.CATEGORY.CODE$, _
DIR.CATEGORY.FILE$, _
NEW.FILES.CHECK, _
MAX.DESC.LEN, _
SHOW.SECTION, _
COMMANDS.IN.PROMPT, _
NEWUSER.SETS.DEFAULTS, _
HELP.PATH$, _
HELP.EXTENSION$, _
MAIN.COMMANDS$, _
FILE.COMMANDS$, _
UTIL.COMMANDS$, _
GLOBAL.COMMANDS$, _
SYSOP.COMMANDS$
ALL.OPTS$ = MAIN.COMMANDS$ + FILE.COMMANDS$ + UTIL.COMMANDS$ + _
GLOBAL.COMMANDS$ + SYSOP.COMMANDS$
HELP.EXTENSION$ = "." + HELP.EXTENSION$
BEG.MAIN = 1
BEG.FILE = LEN(MAIN.COMMANDS$) + BEG.MAIN
BEG.UTIL = LEN(FILE.COMMANDS$) + BEG.FILE
HELP$(3) = HELP.PATH$ + HELP$(3)
HELP$(4) = HELP.PATH$ + HELP$(4)
HELP$(7) = HELP.PATH$ + HELP$(7)
HELP$(9) = HELP.PATH$ + HELP$(9)
'
' *****************************************************************************
' * ESTABLISH COMMUNICATION PORT REGISTERS AND COMMANDS *
' * GET DOS SUB-DIRECTORY RBBS-PC OPTIONS *
' *****************************************************************************
'
INPUT #2, UPLOAD.PATH$, _ ' Where upl dir goes
FMS.DIRECTORY$, _ ' Shared dir in FMS
ANS.MENU$, _
REQUIRED.QUESTIONNAIRE$,_
REMEMBER.NEW.USERS,_
SURVIVE.NOUSER.ROOM,_
PROMPT.HASH$,_
START.HASH,_
LEN.HASH,_
PROMPT.INDIV$,_
START.INDIV,_
LEN.INDIV
INPUT #2, BYPASS.MSGS, _
MUSIC, _
RESTRICT.BY.DATE, _
DAYS.TO.WARN, _
DAYS.IN.SUBSCRIPTION.PERIOD, _
CALLBACK.VERIFICATION, _
RESTRICT.VALID.CMDS, _
NEW.USER.DEFAULT.MODE, _
NEW.USER.LINE.FEEDS, _
NEW.USER.NULLS, _
NEW.USER.BELL, _
NEW.USER.CASE, _
NEW.USER.MARGINS, _
WRAP.CALLERS.FILE$, _
REDIRECT.IO.METHOD, _
GO.TO.SHELL, _
HALT.ON.ERROR, _
NEW.PUBLIC.MSGS.SECURITY, _
NEW.PRIVATE.MSGS.SECURITY, _
SECURITY.NEEDED.TO.CHANGE.MSGS, _
SL.CATEGORIZE.UPLOADS, _
BAUDOT, _
TIME.TO.DROP.TO.DOS, _
EXPIRED.SECURITY, _
DTR.DROP.DELAY, _
ASK.IDENTITY, _
USE.EXTERNAL.XMODEM, _
BUFFER.SIZE, _
MLCOM, _
DUMMY, _
F7.MESSAGE$, _
NEW.USER.DEFAULT.PROTOCOL$, _
NEW.USER.GRAPHICS$, _
NET.MAIL$, _
MASTER.DIRECTORY.NAME$, _
PROTOCOL.PATH$, _
UPCAT.HELP$, _
ALWAYS.STREW.TO$, _
DUMMY$
INPUT #2, DF,_
MODEM.INIT.WAIT.TIME, _
MODEM.COMMAND.DELAY.TIME, _
TURBO.RBBS, _
SUBDIR.COUNT,_
DF,_
UPLOAD.TO.SUBDIR,_
DF,_
UPLOAD.SUBDIR$,_
RESTRICT.BAUD,_
USE.COLOR,_
DISKFULL.GO.OFFLINE,_
EXTENDED.LOGGING,_
MODEM.RESET.COMMAND$,_
MODEM.COUNT.RINGS.COMMAND$,_
MODEM.ANSWER.COMMAND$,_
MODEM.GO.OFFHOOK.COMMAND$,_
DISK.FOR.DOS$, _
DUMB.MODEM, _
COMMENTS.AS.MESSAGES, _
LSB,_
MSB,_
LINE.CONTROL.REGISTER,_
MODEM.CONTROL.REGISTER,_
LINE.STATUS.REGISTER,_
MODEM.STATUS.REGISTER
IF SUBROUTINE.PARAMETER = -62 THEN _
EXIT SUB
REQUIRED.QUESTIONNAIRE$ = REQUIRED.QUESTIONNAIRE$ + ".DEF"
'
' *****************************************************************************
' * ESTABLISH RBBS-PC'S DOS SUBDIRECTORIES USAGE *
' *****************************************************************************
'
IF FMS.DIRECTORY$ <> "" THEN _
FMS.DIRECTORY$ = DIRECTORY.PATH$ + _
FMS.DIRECTORY$ + _
"." + _
DIRECTORY.EXTENTION$
UPCAT.HELP$ = HELP.PATH$ + UPCAT.HELP$ + HELP.EXTENSION$
IF SUBDIR.COUNT<1 THEN _
GOTO 123
FOR SUBDIR.INDEX = 1 TO SUBDIR.COUNT
INPUT #2,SUBDIR$
IF RIGHT$(SUBDIR$,1) <> "\" THEN _
SUBDIR$(SUBDIR.INDEX) = SUBDIR$ + "\" _
ELSE SUBDIR$(SUBDIR.INDEX) = SUBDIR$
NEXT
GOTO 125
'
' *****************************************************************************
' * SETUP DOWNLOAD DRIVES WITH NO SUBDIRECTORY SUPPORT *
' *****************************************************************************
'
123 FOR SUBDIR.INDEX = 1 TO LEN(DOWNLOAD.DRIVES$) - 1
SUBDIR$(SUBDIR.INDEX) = MID$(DOWNLOAD.DRIVES$,SUBDIR.INDEX,1) + ":"
NEXT
SUBDIR.COUNT = LEN(DOWNLOAD.DRIVES$) - 1
'
' *****************************************************************************
' * SETUP UPLOAD DRIVE AND DIRECTORY.NAME *
' *****************************************************************************
'
125 UPLOAD.DIR.CHECK$ = UPLOAD.DIRECTORY$
SUBDIR.COUNT = SUBDIR.COUNT + 1
IF UPLOAD.TO.SUBDIR THEN _
SUBDIR$(SUBDIR.COUNT) = UPLOAD.SUBDIR$ + "\" _
ELSE SUBDIR$(SUBDIR.COUNT) = RIGHT$(DOWNLOAD.DRIVES$,1) + _
":"
UPLOAD.DIRECTORY$ = UPLOAD.DIRECTORY$ + _
"." + _
DIRECTORY.EXTENTION$
CALL CHKNARY (SUBDIR$(SUBDIR.COUNT),SUBDIR$(),SUBDIR.COUNT-1,FOUND)
CAN.DOWNLOAD.FROM.UP = (FOUND > 0)
UPLOAD.DIRECTORY$ = UPLOAD.PATH$ + UPLOAD.DIRECTORY$
126 CLOSE #2
'
' *****************************************************************************
' * INITIALIZE OMNINET INTERFACE IF OMNINET IN USE *
' *****************************************************************************
'
128 IF NETWORK.TYPE = 2 THEN _
CN$ = SPACE$(535) : _
CALL INITIO(A)
END SUB
' $SUBTITLE: 'ANSWERIT - subroutine to answer the phone when it rings'
' $PAGE
'
' SUBROUTINE NAME -- ANSWERIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SUBROUTINE.PARAMETER = 1 WAIT FOR PHONE TO RING
' SUBROUTINE.PARAMETER = 2 CONTINUE LOOKING FOR CONNECT
' SUBROUTINE.PARAMETER = 3 RENTRY AFTER FUNCTION KEY
' SUBROUTINE.PARAMETER = 4 GO ON LINE IMMEDIATELY
' BG LOCAL DISPLAY'S BACKGROUND
' BORDER LOCAL DISPLAY'S BORDER COLOR
' COLOR.SUPPORT ANSI.SYS SUPPORT INDICATOR
' COM.PORT$ COMMUNICATIONS PORT NAME
' COMPUTER.TYPE TYPE OF COMPUTER RUNNING ON
' DUMB.MODEM NON-HAYES TYPE MODEM FLAG
' EXTENDED.LOGGING EXTENDED CALLERS LOG FLAG
' FG LOCAL DISPLAY'S FOREGROUND
' MODEM.ANSWER.COMMAND$ COMMAND TO ANSWER PHONE
' MODEM.CONTROL.REGISTER LOCATION OF MODEM CNTRL. REG
' MODEM.COUNT.RINGS.COMMAND$ COMMAND TO COUNT PHONE RINGS
' MODEM.INIT.BAUD$ BAUDE AT WHICH TO OPEN COMM.
' MODEM.RESET.COMMAND$ COMMAND TO RESET THE MODEM
' MODEM.STATUS.REGISTER LOCATION OF MODEM STATUS REG
' PRINTER FLAG TO PRINT ON LOCAL PRT.
' RESTRICT.BAUD FLAG TO DISALLOW 300 BAUD
' REQUIRED.RINGS NUMBER OF RINGS TO ANSWER ON
' SNOOP FLAG TO DISPLAY ON LOCAL PC
' SYSOP.NEXT FLAG TO GIVE SYSOP CONTROL
'
' OUTPUT PARAMETERS -- BAUD.TEST BAUD RATE TO SET RS232 AT
' EIGHT.BIT PARITY INDICATOR
' RELIABLE.MODE INDICATES MODEM-SUPPLIED
' "ERROR-FREE" PROTOCOL ACTIVE
' SUBROUTINE.PARAMETER = 1 CARRIER DETECT FOUND (I.E.
' MODEM AUTO-ANSWERED).
' = 2 ANSWERED THE PHONE AND
' CARRIER DETECT OCCURRED.
' = 3 SYSOP HIT "ESC" KEY ON THE
' LOCAL KEYBOARD.
' = 4 ANSWERED THE PHONE BUT NO
' CARRIER WAS DETECTED.
' = 5 NOT USED.
' = 6 FUNCTION KEY PRESSED ON THE
' LOCAL KEYBOARD.
'
' SUBROUTINE PURPOSE -- TO ANSWER THE TELEPHONE WHEN IT RINGS.
'
SUB ANSWERIT STATIC
ON ERROR GOTO 65000
EC = 0
RELIABLE.MODE = FALSE
FF = SUBROUTINE.PARAMETER
SUBROUTINE.PARAMETER = 0
ON FF GOTO 201,324,245,320
'
' *****************************************************************************
' * INITIALIZE MODEM AND ANNOUNCE RBBS-PC IS UP AND READY FOR CALLS *
' *****************************************************************************
'
201 SUBROUTINE.PARAMETER = -10
CALL CARRIER
IF SUBROUTINE.PARAMETER = 0 THEN _
GOTO 210
'
' *****************************************************************************
' * RESET THE MODEM VIA THE MODEM CONTROL REGISTER TO ASSURE IT IS READY *
' *****************************************************************************
'
OUT MODEM.CONTROL.REGISTER,&H4
CALL DELAYIT (MODEM.INIT.WAIT.TIME)
'
' *****************************************************************************
' * CLEAR THE MODEM CONTROL REGISTER PRIOR TO OPEN THE COMMUNICATIONS PORT *
' *****************************************************************************
'
OUT MODEM.CONTROL.REGISTER,&H0
CALL DELAYIT (MODEM.INIT.WAIT.TIME)
210 OPEN COM.PORT$ + ":" + MODEM.INIT.BAUD$ + ",N,8,1,RS,CD,DS" AS #3
220 SUBROUTINE.PARAMETER = 1
CALL AMORPM
230 IF PRINTER THEN _
CALL PRINTIT (" RBBS-PC "+VERSION.ID$+" Node "+NODE.ID$+_
" up "+TIM$+" on "+DATE$)
235 EIGHT.BIT = TRUE
SUBROUTINE.PARAMETER = -10
CALL CARRIER
IF SUBROUTINE.PARAMETER = 0 AND _
EXIT.TO.DOORS THEN _
CALL READPROF : _
SUBROUTINE.PARAMETER = 1 : _
GOTO 335
IF SUBROUTINE.PARAMETER = 0 THEN _
GOTO 324
PCJR = FALSE
IF COMPUTER.TYPE = 2 AND _
COM.PORT$ = "COM1" AND _
MODEM.STATUS.REGISTER = 1022 THEN _
MODEM.GO.OFFHOOK.COMMAND$ = CHR$(14) + "P" : _
PCJR = TRUE
IF PCJR THEN _
A$ = CHR$(14) + "I" _
ELSE A$ = MODEM.RESET.COMMAND$
CALL MODEMPUT (A$)
CALL SYSMENU
CALL DELAYIT (MODEM.INIT.WAIT.TIME)
IF PCJR THEN _
A$ = CHR$(14) + _ ' PC-JR'S MODEM COMMAND IDENTIFIER
"C 0," + _ ' SET "AUTO-ANSWER" OFF ON PC-JR'S MODEM
"S 1," + _ ' SET SPEED TO 300 BAUD ON PC-JR'S MODEM
"H" _ ' MANUALLY HANG UP THE PHONE (IF NOT ALREADY)
ELSE A$ = MODEM.INIT.COMMAND$
CALL MODEMPUT (A$)
IF PCJR THEN _
A$ = CHR$(14) + "F 4" : _
CALL MODEMPUT (A$)
RINGBACK = FALSE
LOCATE 22,3
IF REQUIRED.RINGS = 0 THEN _
PRINT "WAITING FOR CARRIER"; : _
GOTO 237
IF MID$(MODEM.INIT.COMMAND$, _
INSTR(MODEM.INIT.COMMAND$,"S0")+3,3) = "255" THEN _
PRINT "RING BACK SYSTEM"; : _
RINGBACK = TRUE : _
GOTO 236
PRINT "WAITING FOR RING ";
236 LOCATE 22,24 : _
PRINT MID$(STR$(REQUIRED.RINGS),2);
237 LOCATE 18,51
COLOR FG+16
PRINT "YES";
COLOR FG
LOCATE 22,28
'
' *****************************************************************************
' * GET READY TO ANSWER INCOMMING CALL: *
' * 1. LET THE MODEM "AUTO-ANSWER" FOR RBBS-PC. *
' * REQUIRED RINGS = 0 AND S0 = 1 IN MODEM INIT COMMAND. *
' * 2. ANSWER THE MODEM ON A SPECIFIED NUMBER OF RINGS. *
' * REQUIRED RINGS > 0 AND S0 = 254 IN MODEM INIT COMMAND. *
' * 3. ANSWER THE MODEM ON A SPECIFIED NUMBER OF RINGS AFTER A USER *
' * FIRST CALLS AND THEN HANGS UP (I.E. RING-BACK). *
' * REQUIRED RINGS > 0 AND S0 = 255 IN MODEM INIT COMMAND. *
' *****************************************************************************
'
QQ = 255
I = INSTR(MODEM.INIT.COMMAND$,"S0")
IF I = 0 OR PCJR THEN _
GOTO 239
IF VAL(MID$(MODEM.INIT.COMMAND$,I+3,3)) = 255 THEN _
QQ = 0 : _
BLK = QQ
CALL FINDTIME (TCA!)
SUBROUTINE.PARAMETER = 1
CALL LINE25
RING.ANSWER = TRUE
IF RINGBACK THEN _
RING.ANSWER = FALSE
239 RINGBACK.WAIT.STARTED! = 0
IF RINGBACK THEN _
CALL FINDTIME (RINGBACK.WAIT.STARTED!) : _
COLOR 7,0,0 _
ELSE COLOR FG,BG,BORDER
240 IF SYSOP.NEXT THEN _
SUBROUTINE.PARAMETER = 3 : _
EXIT SUB
'
' *****************************************************************************
' * WAIT FOR INCOMING CALLS *
' *****************************************************************************
'
245 WHILE INP(MODEM.STATUS.REGISTER) < 128
CALL FINDFUNC
IF FUNCTION.KEY >0 THEN _
SUBROUTINE.PARAMETER = 6 : _
EXIT SUB
250 IF KEY.PRESSED$ = ESCAPE$ THEN _
SUBROUTINE.PARAMETER = 3 : _
EXIT SUB
260 IF RINGBACK.WAIT.STARTED! > 0 THEN _
CALL FINDTIME (TI!) : _
IF ABS(TI! - RINGBACK.WAIT.STARTED!) > 45 THEN _
RINGBACK.WAIT.STARTED! = 0 : _
RING.BACK.COUNT = 0 : _
RING.ANSWER = FALSE: _
IF (SNOOP AND RINGBACK) THEN _
PRINT "Ringback timeout";PAGING.PRINTER.SUPPORT$
265 CALL FINDTIME (TI!)
IF ABS(TI! - TCA!) > 120 THEN _
LOCATE ,,0 : _
CLS : _
C.L = 1 : _
CALL FINDTIME (TCA!)
266 IF (INP(MODEM.STATUS.REGISTER) AND &H40) > 0 AND _
REQUIRED.RINGS > 0 THEN _
GOTO 276
270 WEND
IF REQUIRED.RINGS = 0 THEN _
GOTO 321
'
' *****************************************************************************
' * PREPARE TO ANSWER THIS CALL ON A SPECIFIED NUMBER OF RINGS (S0 = 254) OR *
' * THE CALL AFTER THIS CALL ON A SPECIFIED NUMBER OF RINGS (S0 = 255) -- *
' * "RING BACK." *
' *****************************************************************************
'
276 IF LOC(3) THEN _
X$ = INPUT$(LOC(3),3)
277 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0
IF PCJR THEN _
GOTO 320
A$ = MODEM.COUNT.RINGS.COMMAND$
CALL MODEMPUT (A$)
CALL DELAYIT (MODEM.COMMAND.DELAY.TIME)
290 X$ = INPUT$(LOC(3),3)
291 IF LEN(X$) = 0 THEN _
GOTO 310
292 X$=MID$(X$,INSTR(X$,"0"))
293 IF (NOT RING.ANSWER) AND (VAL(X$) < RING.BACK.COUNT) THEN _
RING.ANSWER = TRUE
300 RING.BACK.COUNT = VAL(X$)
Q = RING.BACK.COUNT + 1
IF (NOT RING.ANSWER) THEN _
Q = 0
305 IF SNOOP THEN _
PRINT TIME$ + " Ring " + STR$(Q);
310 IF (RING.BACK.COUNT+1 < REQUIRED.RINGS) OR _
(NOT RING.ANSWER) THEN _
GOTO 239
320 IF PCJR THEN _
A$ = CHR$(14) + _ ' PC-JR'S MODEM COMMAND IDENTIFIER
"T 0," + _ ' SET PC-JR'S MODEM TO TRANSPARENT MODE PERMANENTLY
"M" _ ' TELL THE PC-JR'S MODEM TO ANSWER IN DATA MODE
ELSE A$ = MODEM.ANSWER.COMMAND$
CALL MODEMPUT (A$)
'
' *****************************************************************************
' * TEST FOR CARRIER PRESENT *
' *****************************************************************************
'
321 CALL FINDTIME (CONNECT.DELAY!)
CONNECT.DELAY! = CONNECT.DELAY! + 30
IF CONNECT.DELAY! > 86399 THEN _
CONNECT.DELAY! = 86399
MODEM.RESPONSE$ = ""
322 CALL FINDTIME (TI!)
323 SUBROUTINE.PARAMETER = -9
CALL CARRIER
IF SUBROUTINE.PARAMETER AND _
TI! < CONNECT.DELAY! THEN _
GOTO 322
IF SUBROUTINE.PARAMETER THEN _
SUBROUTINE.PARAMETER = 4 : _
EXIT SUB
CALL DELAYIT (3)
324 SUBROUTINE.PARAMETER = 0
MODEM.RESPONSE$ = MODEM.RESPONSE$ + INPUT$(LOC(3),3)
325 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 323
IF SUBROUTINE.PARAMETER = 5 THEN _
EXIT SUB
CALL FINDTIME (TI!)
IF TI! > CONNECT.DELAY! THEN _
CALL UPDTCALR ("Connect timeout",1) : _
SUBROUTINE.PARAMETER = 4 : _
EXIT SUB
IF DUMB.MODEM THEN _
BAUD.TEST = VAL(MODEM.INIT.BAUD$) : _
GOTO 326
IF INSTR(MODEM.RESPONSE$,"CONNECT") THEN _
BAUD.TEST = VAL(MID$(MODEM.RESPONSE$,INSTR(MODEM.RESPONSE$,"CONNECT") + 8,4)) : _
GOTO 326
IF INSTR(MODEM.RESPONSE$,"ONLINE") THEN _
BAUD.TEST = VAL(MID$(MODEM.RESPONSE$,INSTR(MODEM.RESPONSE$,"ONLINE") + 7,4)) : _
GOTO 326
GOTO 324
326 IF INSTR(MODEM.RESPONSE$,"REL") OR _
INSTR(MODEM.RESPONSE$,"R C") OR _ (ERROR CONTROL)
INSTR(MODEM.RESPONSE$,"ARQ") OR _
INSTR(MODEM.RESPONSE$,"MNP") THEN _
RELIABLE.MODE = TRUE
IF BAUD.TEST = 0 OR BAUD.TEST = 300 THEN _
BAUD.TEST = 300 : _
BPS = -1 : _
BAUD.RATE.DIVISOR = &H180 + (11*(COMPUTER.TYPE = 2)) : _
GOTO 331
IF BAUD.TEST = 1200 THEN _
BPS = -3 : _
BAUD.RATE.DIVISOR = &H60 + (3*(COMPUTER.TYPE = 2)) : _
GOTO 331
IF BAUD.TEST = 2400 THEN _
BPS = -4 : _
BAUD.RATE.DIVISOR = &H30 + (1*(COMPUTER.TYPE = 2)) : _
GOTO 331
IF BAUD.TEST = 4800 OR BAUD.TEST = 9600 THEN _
BPS = -4-(BAUD.TEST /4800) : _
BAUD.RATE.DIVISOR = 12 * (BPS + 7) : _
GOTO 331
GOTO 324
331 CALL SETBAUD
SUBROUTINE.PARAMETER = 2
335 IF NOT RELIABLE.MODE THEN _
A = INSTR(TRANSFER.OPTIONS$,"I)") : _
IF A>0 THEN _
TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,A-1) + _
MID$(TRANSFER.OPTIONS$,A+20)
END SUB
' $SUBTITLE: 'PASSWORD - verify User and Message passwords'
' $PAGE
'
' SUBROUTINE NAME -- PASSWORD
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SUBROUTINE.PARAMETER = 1 VERIFY USER PASSWORD
' SUBROUTINE.PARAMETER = 2 VERIFY MESSAGE PASSWORD
' SUBROUTINE.PARAMETER = 3 VERIFY MESSAGE PASSWORD
' SUBROUTINE.PARAMETER = 4 VERIFY MESSAGE PASSWORD
' SUBROUTINE.PARAMETER = 5 VERIFY MESSAGE PASSWORD
'
' OUTPUT PARAMETERS -- PASSWORD.FAILED SET TO 0 IF PASSED
' SET TO -1 IF FAILED
'
' SUBROUTINE PURPOSE -- TO VERIFY USER AND MESSAGE PASSWORDS
'
SUB PASSWORD STATIC
ON ERROR GOTO 65000
EC = 0
ON SUBROUTINE.PARAMETER GOTO 665,667,670,675,677
665 IF PASSWORD.SAVE$ = PASSWORD$ THEN _
PASSWORD.FAILED = 0 : _
EXIT SUB
667 ATTEMPTS = 0
670 ATTEMPTS = ATTEMPTS + 1
IF ATTEMPTS > ATTEMPTS.ALLOWED THEN _
PASSWORD.FAILED = TRUE : _
EXIT SUB
675 A$ = "Enter Password (dots echo)"
HIDDEN = TRUE
SUBROUTINE.PARAMETER = 1
CALL TGET
HIDDEN = FALSE
SUBROUTINE.PARAMETER = 5
CALL TPUT
Z$ = B$(1)
677 IF LEN(Z$) > 15 THEN _
GOTO 680
IF EC <> 0 THEN _
GOTO 670
CALL ALLCAPS (Z$)
Z$ = Z$ + SPACE$(15-LEN(Z$))
IF PASSWORD.SAVE$ = Z$ THEN _
PASSWORD.FAILED = 0 : _
EXIT SUB
680 IF MESSAGE.PASSWORD THEN _
CALL QTPUT("Wrong password entered",1)
GOTO 670
END SUB
' $SUBTITLE: 'TPUT -- RBBS-PC common routine to write to comm. port'
' $PAGE
'
' SUBROUTINE NAME -- TPUT (TERMINAL PUT)
'
' INPUT PARAMETERS -- PARAMETER MEANING
' A$ STRING TO WRITE TO THE
' COMMUNICATIONS PORT
' SUBROUTINE.PARAMETER = 1 SKIP A LINE BEFORE WRITING
' TO THE COMMUNICATIONS PORT
' SUBROUTINE.PARAMETER = 2 SKIP A LINE BEFORE WRITING
' TO THE COMMUNICATIONS PORT
' AND THEN SKIP TWO LINES
' AFTER WRITING TO THE COMM-
' UNICATIONS PORT
' SUBROUTINE.PARAMETER = 3 WRITE TO THE COMMUNICATIONS
' PORT AND THEN SKIP TWO
' LINES
' SUBROUTINE.PARAMETER = 4 WRITE TO THE COMMUNICATIONS
' PORT WITHOUT A CR/LF
' SUBROUTINE.PARAMETER = 5 WRITE TO THE COMMUNICATIONS
' PORT WITH A CR/LF
' SUBROUTINE.PARAMETER = 6 RESET EVERYTHING FOR INPUT
' STRING
' SUBROUTINE.PARAMETER = 7 RE-ENTRY AFTER HANDLING A
' FUNCTION KEY
'
' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = -1 CARRIER HAS BEEN DROPPED
' FUNCTION.KEY <> 0 FUNCTION KEY PRESSED
'
' SUBROUTINE PURPOSE -- COMMON OUTPUT ROUTINE FOR RBBS-PC TO THE
' COMMUNICATIONS PORT (TERMINAL PUT)
SUB TPUT STATIC
ON ERROR GOTO 65000
HALT.IT = 0
IF SUBROUTINE.PARAMETER <> 7 THEN _
PARM = SUBROUTINE.PARAMETER
ON SUBROUTINE.PARAMETER GOTO 1398,1399,1400,1403,1405,1450,1411
'
' *****************************************************************************
' * COMMON OUTPUT ROUTINE *
' *****************************************************************************
'
1398 CALL SKIPLINE (1)
GOTO 1405
1399 CALL SKIPLINE (1)
1400 CR = 1
1403 CR = CR + 1
1405 RET = FALSE
IF NOT STOP.INTERRUPTS OR CM THEN _
GOTO 1435
1410 CALL FINDFUNC
IF FUNCTION.KEY <> 0 THEN _
EXIT SUB
1411 Y$ = KEY.PRESSED$
SUBROUTINE.PARAMETER = PARM
IF LOCAL.USER THEN _
GOTO 1430
IF EOF(3) THEN _
CALL CARRIER : _
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB _
ELSE GOTO 1430
1420 Y$ = INPUT$(1,3)
1421 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 1420
1425 IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
IF Y$ = XOFF$ THEN _
WHILE EOF(3) : _
GOSUB 1473 : _
CALL CARRIER : _
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB _
ELSE WEND : _
GOTO 1420
1430 IF (Y$ = CHR$(11) OR _ ' INTERRUPT OUTPUT IF:
Y$ = CANCEL$ OR _ ' CTRL / K
Y$ = XOFF$) AND _ ' CTRL / X
STOP.INTERRUPTS THEN _ ' CTRL / S
GOTO 1475
1435 IF NOT SNOOP THEN _
GOTO 1437
LOCATE ,,1
IF COLOR.SUPPORT AND A$ <> "" THEN _
CALL ANSI(A$,C.C,C.L) : _
LOCATE C.C,C.L : _
GOTO 1437
CALL PRTCRLF (A$)
1437 IF LOCAL.USER THEN _
GOTO 1450
IF UPPER.CASE THEN _
CALL ALLCAPS (A$)
IF INP(MODEM.STATUS.REGISTER) > 127 THEN _
PRINT #3,A$;
1450 IF CR <> 1 THEN _
CALL SKIPLINE (1) _
ELSE IF CR > 1 THEN _
CALL SKIPLINE (1)
1470 Y$ = ""
A$ = Y$
CR = 0
IF HALT.IT = 0 THEN _
EXIT SUB
STOP.INTERRUPTS = RET
RET = TRUE
NON.STOP = FALSE
EXIT SUB
1473 IF MULTI.LINK.PRESENT > 0 THEN _
AX = &H200 : _
BX = &H0 : _
CALL RBBSML(AX,BX)
RETURN
1475 CR = 2
RET = STOP.INTERRUPTS
STOP.INTERRUPTS = FALSE
HALT.IT = 1
GOTO 1410
END SUB
' $SUBTITLE: 'OPENRSEQ - subroutine open sequential file randomly'
' $PAGE
'
' SUBROUTINE NAME -- OPENRSEQ
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF SEQUENTIAL FILE TO OPEN AS #2
'
' OUTPUT PARAMETERS -- NUM.RECS NUMBER OF 128-BYTE RECORDS IN THE FILE
' LEN.LAST.REC NUMBER OF BYTES IN THE LAST RECORD (IT
' MAY BE LESS THAN OR EQUAL TO 128).
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO OPEN A SEQUENTIAL FILE AS FILE # 2 AND
' READ IT RANDOMLY.
'
SUB OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC) STATIC
1479 ON ERROR GOTO 65000
CLOSE 2
1480 EC = 0
1481 IF SHARE.IT THEN _
OPEN FILNAME$ FOR RANDOM SHARED AS #2 LEN=BUFFER.SIZE _
ELSE OPEN "R",2,FILNAME$,BUFFER.SIZE
IF EC = 52 THEN _
GOTO 1480
I# = LOF(2)
NUM.RECS = FIX(I#/BUFFER.SIZE)
LEN.LAST.REC = I# - NUM.RECS*BUFFER.SIZE
IF LEN.LAST.REC > 0 THEN _
NUM.RECS = NUM.RECS + 1 _
ELSE LEN.LAST.REC = BUFFER.SIZE
END SUB
' $SUBTITLE: 'TGET -- RBBS-PC common routine to ask a user a question'
' $PAGE
'
' SUBROUTINE NAME -- TGET
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SUBROUTINE.PARAMETER = 1 STANDARD ENTRY
' SUBROUTINE.PARAMETER = 2 ENTRY AFTER A FUNCTION KEY
' HAS BEEN HANDLED
' A$ STRING TO WRITE TO THE
' COMMUNICATIONS PORT
' HIDDEN IF THIS IS TRUE THEN ECHO
' '.' INSTEAD OF ACTUAL
' CHARACTER ENTERED.
'
' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = -1 CARRIER HAS BEEN DROPPED
' B$ STRING THAT WAS ENTERED
' Q NUMBER OF PARAMETERES THAT
' WERE ENTERED WHICH WHERE
' SEPARATED BY A SEMICOLON
' B$() STRING MATRIX WITH EACH
' ITEM CONTAIN THE STRING
' THAT WAS ENTERED BETWEEN
' SEMICOLONS.
' FUNCTION.KEY <> 0 FUNCTION KEY PRESSED
' YES REPLY IS "Y" OR "YES"
' NO REPLY IS "N" OR "NO"
' NON.STOP REPLY IS "NS" OR "ns"
' KILL.MESSAGE REPLY IS "K"
' REPLY REPLY IS "RE"
'
' SUBROUTINE PURPOSE -- COMMON ROUTINE TO ASK A USER A QUESTION
'
SUB TGET STATIC
ON ERROR GOTO 65000
ON SUBROUTINE.PARAMETER GOTO 1500,1526
'
' *****************************************************************************
' * COMMON INPUT ROUTINE *
' *****************************************************************************
'
1500 CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
LINES.PRINTED = 0
TOA! = FRE("A")
CALL FINDTIME (AUTO.LOGOFF!)
AUTO.LOGOFF! = AUTO.LOGOFF! + WAIT.BEFORE.DISCONNECT
A = 0
B = 0
C = 0
Q = 1
EOL = FALSE
YES = FALSE
B$ = ""
NO = FALSE
A$ = A$ + "? "
SUBROUTINE.PARAMETER = 4
CALL TPUT
IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
EXIT SUB
IF NOT LOCAL.USER THEN 1523
LINE INPUT "",B$
IF NO.ADVANCE THEN _
NO.ADVANCE = FALSE : _
LOCATE CSRLIN-1,1 : _
CALL WIPELINE (79)
GOTO 1575
1523 IF PROMPT.BELL AND INP(MODEM.STATUS.REGISTER) >127 THEN _
PRINT #3,CHR$(7);
1525 IF NOT EOF(3) THEN _
GOTO 1528
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
CALL FINDTIME (TI!)
IF TI! > AUTO.LOGOFF! THEN _
CALL UPDTCALR ("Sleep disconnect",1) : _
SUBROUTINE.PARAMETER = -1 : _
EXIT SUB
CALL FINDFUNC
IF FUNCTION.KEY <> 0 THEN _
EXIT SUB
1526 Y$ = KEY.PRESSED$
IF Y$ <> "" THEN _
GOTO 1545
GOTO 1525
1528 CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
1540 Y$ = INPUT$(1,3)
1541 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 1540
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
IF TEST.PARITY THEN _
GOTO 1542
IF Y$ = CHR$(127) THEN _
GOTO 1635
GOTO 1545
1542 IF ASC(Y$) = 141 THEN _
OUT LINE.CONTROL.REGISTER,&H1A : _
EIGHT.BIT = FALSE : _
TEST.PARITY = FALSE : _
GR = FALSE
Y$ = CHR$(ASC(Y$) AND 127)
1545 IF INSTR(LINEEDIT.CHK$,Y$) > 5 _
GOTO 1635
IF Y$ < " " AND Y$ <> CARRIAGE.RETURN$ THEN _
GOTO 1525
IF Y$ = "^" THEN _
GOTO 1525
IF Y$ = CARRIAGE.RETURN$ THEN _
IF NO.ADVANCE THEN _
NO.ADVANCE = FALSE : _
GOTO 1575_
ELSE_
GOSUB 1550 : _
GOTO 1570_
ELSE_
GOSUB 1550
IF LEN(B$) >= 254 THEN _
A$ = "Input too long!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
EXIT SUB _
ELSE GOTO 1500
B$ = B$ + Y$
GOTO 1525
1550 IF SNOOP THEN _
PRINT Y$;
IF INP(MODEM.STATUS.REGISTER) > 127 THEN _
IF HIDDEN THEN _
PRINT #3,"."; _
ELSE _
PRINT #3,Y$;
RETURN
1570 IF LINE.FEEDS AND INP(MODEM.STATUS.REGISTER) > 127 THEN _
PRINT #3,LINE.FEED$;
1575 A = INSTR(B$,";")
IF A < 2 THEN _
GOTO 1620
B$(1) = LEFT$(B$,A-1)
A = A + 1
1585 B = INSTR(A,B$,";")
C = B-A
IF C < 1 THEN _
EOL = TRUE : _
C = 128
DF$ = MID$(B$,A,C)
IF DF$ <> "" THEN _
Q = Q + 1 : _
B$(Q) = DF$
IF NOT EOL AND Q < 10 THEN _
A = B + 1 : _
GOTO 1585
IF LEN(B$) > 4000 THEN _
A$ = "Try again, " + FIRST.NAME$ : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
EXIT SUB _
ELSE GOTO 1500
GOTO 1625
1620 B$(1) = B$
Q = 1
IF B$ = "" THEN _
Q = 0 : _
EXIT SUB
1625 CALL ALLCAPS (B$)
IF LEN(B$) < 4 THEN _
X$ = LEFT$(B$,3): _
IF X$ = "Y" OR X$ = "YES" THEN _
YES = TRUE _
ELSE IF X$ = "N" OR X$ = "NO" THEN _
NO = TRUE
IF B$(Q) = "NS" OR B$(Q) = "ns" THEN _
NON.STOP = TRUE : _
B$(Q) = "" : _
IF Q > 1 THEN _
Q = Q-1
IF B$ = "RE" THEN _
REPLY = TRUE : _
EXIT SUB
IF B$ = "K" THEN _
KILL.MESSAGE = TRUE
EXIT SUB
1635 IF LEN(B$) = 0 THEN _
GOTO 1525
B$ = LEFT$(B$,LEN(B$)-1)
IF SNOOP THEN _
PRINT BACK.ARROW$;
IF INP(MODEM.STATUS.REGISTER) > 127 THEN _
PRINT #3,BACKSPACE$;
GOTO 1525
END SUB
' $SUBTITLE: 'LINEEDIT - subroutine to produce edited line'
' $PAGE
'
' SUBROUTINE NAME -- LINEEDIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' BACK.ARROW$
' BACKSPACE$
' CARRIAGE.RETURN$
' LINE.FEED$
' LINEMES$ BUFFER SPACE TO USE FOR HOLDING LINE
' LOCAL.USER
' MAX.LEN MAXIMUM LENGTH OF STRING TO INPUT
' MESSAGE.LINE WHERE IN A$() TO PUT THE EDITED LINE
' RIGHT.MARGIN
' SNOOP
' STOP.INTERRUPTS
' WAIT.EXPIRED
'
' OUTPUT PARAMETERS -- A$(MESSAGE.LINE) EDITED LINE
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO EDIT A LINE QUICKLY USING A MINIMUM OF
' STRING SPACE.
'
SUB LINEEDIT (MESSAGE.LINE,MAX.LEN) STATIC
3700 LSET LINEMES$ = A$(MESSAGE.LINE)
COL = LEN(A$(MESSAGE.LINE))
STOP.INTERRUPTS = FALSE
XXX = MAX.LEN - 3
WAIT.EXPIRED = FALSE
3720 COL = COL + 1
CALL FINDTIME (TI!)
AUTO.LOGOFF! = TI! + WAIT.BEFORE.DISCONNECT
3730 CALL FINDFUNC
IF FUNCTION.KEY <> 0 THEN _
EXIT SUB
X$ = KEY.PRESSED$
IF X$ = "" THEN _
IF LOCAL.USER THEN _
GOTO 3730 _
ELSE _
GOTO 3732
IF X$ = ESCAPE$ THEN _
KEY.PRESSED$ = X$: _
EXIT SUB
Z = INSTR(LINEEDIT.CHK$,X$)
IF Z < 1 THEN_
GOTO 3750_
ELSE IF Z > 4 THEN _
GOTO 3870
IF LOCAL.USER THEN _
GOTO 3730
3732 IF NOT EOF(3) THEN _
GOTO 3736
CALL FINDTIME (TI!)
IF TI! > AUTO.LOGOFF! THEN _
WAIT.EXPIRED = TRUE : _
EXIT SUB
3733 CALL CARRIER
IF SUBROUTINE.PARAMETER THEN _
EXIT SUB
GOTO 3730
3736 AUTO.LOGOFF! = TI! + WAIT.BEFORE.DISCONNECT
3737 X$ = INPUT$(1,3)
3740 ON INSTR(LINEEDIT.CHK$,X$) GOTO 3730,3730,3730,3730,3870,3870,3870,3870,3870
3750 A$ = X$
SUBROUTINE.PARAMETER = 4
CALL TPUT
IF X$ = CARRIAGE.RETURN$ THEN _
COL = COL - 1 : _
GOTO 3850
3770 IF COL > XXX THEN _
IF X$ = " " THEN _
SUBROUTINE.PARAMETER = 5: _
CALL TPUT : _
GOTO 3860
3780 MID$(LINEMES$,COL) = X$
IF COL < MAX.LEN THEN _
GOTO 3720
Z = COL
3800 IF Z < 1 THEN _
Z = COL-1 : _
GOTO 3820
IF MID$(LINEMES$,Z,1) = " " THEN _
GOTO 3820
Z = Z - 1
GOTO 3800
3820 COL = MAX.LEN - Z
IF SNOOP THEN _
LOCATE ,POS(0)-COL: _
PRINT STRING$(COL,32);
3830 CALL CARRIER
IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = 0 THEN _
PRINT #3,STRING$(COL,8) + STRING$(COL,32);
3840 A$(MESSAGE.LINE) = LEFT$(LINEMES$,Z)
A$(MESSAGE.LINE + 1) = MID$(LINEMES$,Z+1,COL)
SUBROUTINE.PARAMETER = 5
CALL TPUT
EXIT SUB
3850 CALL CARRIER
IF NOT LOCAL.USER AND LINE.FEEDS AND _
SUBROUTINE.PARAMETER = 0 THEN _
PRINT #3,LINE.FEED$;
3860 A$(MESSAGE.LINE) = LEFT$(LINEMES$,COL)
EXIT SUB
3870 IF COL = 1 THEN _
GOTO 3730
COL = COL-2
3880 IF SNOOP THEN _
PRINT BACK.ARROW$;
3885 CALL CARRIER
IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = 0 THEN _
PRINT #3,BACKSPACE$;
3890 GOTO 3720
END SUB
' $SUBTITLE: 'BAUD450 -- Changes 300 baud to 450'
' $PAGE
' SUBROUTINE NAME -- BAUD450
'
' INPUT PARAMETERS -- PARAMETER MEANING
' BPS
'
' OUTPUT PARAMETERS -- BPS
'
' SUBROUTINE PURPOSE -- ALLOW 300 BAUD MODEMS TO BUMP UP TO 450 BAUD
'
SUB BAUD450 STATIC
ON ERROR GOTO 65000
IF BPS <> -1 THEN _
CALL QTPUT ("Sorry, only 300 baud can change speed",1) : _
EXIT SUB
5507 A$ = "Change to 450 baud (Y,[N])"
SUBROUTINE.PARAMETER = 1
CALL TGET
IF NOT YES THEN _
EXIT SUB
5510 A$ = "Change. Then press [ENTER] until I respond"
SUBROUTINE.PARAMETER = 9
CALL TGET
CALL DELAYIT (9)
C = 0
BAUD.RATE.DIVISOR = &H100
CALL SETBAUD
5530 C = C + 1
CALL CARRIER
IF SUBROUTINE.PARAMETER THEN _
EXIT SUB
IF C = 20 THEN _
CALL UPDTCALR ("Baud change failed",1) : _
EXIT SUB
CALL DELAYIT (1)
5535 IF EOF(3) THEN _
GOTO 5530
5536 IF ASC(INPUT$(1,3)) = 13 THEN _
GOTO 5540
5537 GOTO 5530
5540 A$ = "Changed to 450 baud"
CALL QTPUT (A$,1)
CALL UPDTCALR (A$,1)
BPS = -2
END SUB
' $SUBTITLE: 'OPENUSER - subroutine to open the users file as #5'
' $PAGE
'
' SUBROUTINE NAME -- OPENUSER
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SHARE.IT
'
' OUTPUT PARAMETERS -- ACTIVE.USER.FILE$
' CITY.STATE$
' ELAPSED.TIME$
' LAST.DATE.TIME.ON$
' LIST.NEW.DATE$
' MACHINE.TYPE$
' PASSWORD$
' SECURITY.LEVEL$
' USER.DOWNLOADS$
' USER.NAME$
' USER.OPTIONS$
' USER.RECORD$
' USER.UPLOADS$
'
' SUBROUTINE PURPOSE -- OPEN THE USER FILE AS FILE # 5
'
SUB OPENUSER STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * OPEN AND DEFINE USER FILE RECORD VARIABLES *
' *****************************************************************************
'
9400 CLOSE 5
IF SHARE.IT THEN _
OPEN ACTIVE.USER.FILE$ FOR RANDOM SHARED AS #5 LEN=128 _
ELSE OPEN "R",5,ACTIVE.USER.FILE$,128
FIELD 5,31 AS USER.NAME$, _
15 AS PASSWORD$, _
2 AS SECURITY.LEVEL$, _
14 AS USER.OPTIONS$, _
24 AS CITY.STATE$, _
19 AS MACHINE.TYPE$, _
14 AS LAST.DATE.TIME.ON$, _
3 AS LIST.NEW.DATE$, _
2 AS USER.DOWNLOADS$, _
2 AS USER.UPLOADS$, _
2 AS ELAPSED.TIME$
FIELD 5,128 AS USER.RECORD$
END SUB
' $SUBTITLE: 'FINDUSER - subroutine to search users file for a name'
' $PAGE
'
' SUBROUTINE NAME -- FINDUSER
'
' INPUT PARAMETERS -- PARAMETER MEANING
' HASH.TO.LOOK.FOR$ STRING TO SEARCH FOR IN USERS
' INDIV.TO.LOOK.FOR$ STRING TO USE TO INDIVIDUATE
' USERS WITH SAME HASH
' START.HASH.POS WHERE HASH FIELD STARTS IN THE
' "USERS" FILE
' LEN.HASH.FIELD LENGTH OF THE HASH FIELD
' START.INDIV.POS WHERE THE FIELD TO DISTINGUISH
' AMONG USERS (I.E. WITH THE SAME
' NAME) STARTS IN THE "USERS" FILE
' (SET TO 0 IF NONE TO BE USED)
' LEN.INDIV.FIELD LENGTH OF FIELD TO DISTINGUISH
' AMONG USERS
' MAX.POSITION HIGHEST RECORD TO SEARCH OR USE
'
' NOTE: THIS SUBROUTINE ASSUMES THE "USERS" FILE IS OPEN AS FILE 2.
'
' OUTPUT PARAMETERS -- WHETHER.FOUND SET TO "TRUE" IF USER WAS FOUND
' OTHERWISE IT IS "FALSE"
' POS.TO.USE NUMBER OF THE "USERS" RECORD THAT
' BELONGS TO THE USER (IF FOUND) OR
' TO USE FOR THE USER (IF THE USER
' WASN'T FOUND)
' POS.TO.RECLAIM SET TO 0 IF THE RECORD NUMBER
' SELECTED FOR THIS USER HAS NEVER
' BEEN USED.
'
' SUBROUTINE PURPOSE -- TO SEARCH THE "USERS" FILE AND DETERMINE THE RECORD
' NUMBER TO USE FOR THE CALLER IN THE "USERS" FILE.
'
SUB FINDUSER (HASH.TO.LOOK.FOR$,INDIV.TO.LOOK.FOR$,START.HASH.POS,_
LEN.HASH.FIELD,START.INDIV.POS,LEN.INDIV.FIELD,_
MAX.POSITION,WHETHER.FOUND,_
POS.TO.USE,POS.TO.RECLAIM) STATIC
ON ERROR GOTO 65000
EC = 0
WHETHER.FOUND = 0
IF HASH.TO.LOOK.FOR$ = SPACE$(LEN(HASH.TO.LOOK.FOR$)) THEN _
EXIT SUB
EMPTY.REC$ = SPACE$(LEN.HASH.FIELD)
EMPTY.INDIV$ = SPACE$(LEN.INDIV.FIELD)
NEWUSER$ = LEFT$("NEWUSER ",LEN.HASH.FIELD+2)
FIELD 5, 128 AS FILLER$
X$ = HASH.TO.LOOK.FOR$ + SPACE$(LEN.HASH.FIELD-LEN(HASH.TO.LOOK.FOR$))
CALL HASHRBBS (HASH.TO.LOOK.FOR$,MAX.POSITION,POS.TO.USE,DF)
Y$ = INDIV.TO.LOOK.FOR$ + SPACE$(LEN.INDIV.FIELD-LEN(INDIV.TO.LOOK.FOR$))
POS.TO.RECLAIM = 0
12610 GET 5,POS.TO.USE
IF EC > 0 THEN _
EC = 0 : _
IF EC = 63 THEN _
GOTO 12621 _
ELSE GOTO 12620
HASH.VALUE$ = MID$(FILLER$,START.HASH.POS,LEN.HASH.FIELD)
IF X$ = HASH.VALUE$ THEN _
IF START.INDIV.POS < 1 THEN _
WHETHER.FOUND = TRUE : _
GOTO 12622 _
ELSE INDIV.VALUE$ = MID$(FILLER$,START.INDIV.POS,LEN.INDIV.FIELD):_
IF Y$ = INDIV.VALUE$ OR INDIV.VALUE$ = EMPTY.INDIV$ THEN _
WHETHER.FOUND = TRUE : _
GOTO 12622
IF HASH.VALUE$ = EMPTY.REC$ THEN _
POS.TO.USE = POS.TO.RECLAIM-(POS.TO.RECLAIM = 0)*POS.TO.USE : _
WHETHER.FOUND = FALSE : _
GOTO 12622
IF ASC(HASH.VALUE$) = 0 OR INSTR(HASH.VALUE$,NEWUSER$) = 1 THEN _
IF POS.TO.RECLAIM = 0 THEN _
POS.TO.RECLAIM = POS.TO.USE
12620 POS.TO.USE = POS.TO.USE + DF
IF POS.TO.USE > MAX.POSITION-1 THEN _
POS.TO.USE = POS.TO.USE-MAX.POSITION
GOTO 12610
12621 IF POS.TO.RECLAIM = 0 THEN _
POS.TO.RECLAIM = POS.TO.USE
GOTO 12620
12622 END SUB
' $SUBTITLE: 'UPDTCALR - subroutine to write to CALLERS file'
' $PAGE
'
' SUBROUTINE NAME -- UPDTCALR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' ERRMES$ MESSAGE TO GO IN CALLER LOG
' EXT.LOG = 1 CHECK FOR EXTENDED LOGGING
' BEFORE UPDATING.
' = 2 UPDATE CALLER LOG WITH Z$
'
' OUTPUT PARAMETERS -- CURRENT.DATE$ CURRENT DATE (MM-DD-YY)
' TIM$ CURRENT TIME (I.E. 1:13 PM)
' TIME.LOGGEND.ON$ TIME USER LOGGED ON (HH:MM:SS)
'
' SUBROUTINE PURPOSE -- TO UPDATE THE CALLER'S FILE AND/OR PRINT ON THE
' LOCAL PRINTER IF IT IS ENABLED
'
SUB UPDTCALR (ERRMES$,EXT.LOG) STATIC
ON ERROR GOTO 65000
FIELD 4, 64 AS CALLERS.RECORD$
LSET CALLERS.RECORD$ = ERRMES$
ON EXT.LOG GOTO 13665,13670
'
' *****************************************************************************
' * EXTENDED LOGGING ENTRY *
' *****************************************************************************
'
13665 IF NOT EXTENDED.LOGGING THEN _
EXIT SUB
SUBROUTINE.PARAMETER = 2
A = INSTR(CALLERS.RECORD$," ")+1
IF A>1 THEN _
CALL AMORPM:_
MID$(CALLERS.RECORD$,A) = " at " + TIM$
'
' *****************************************************************************
' * UPDATE CALLERS FILE WITH USER ACTIVITY *
' *****************************************************************************
'
13670 LSET CALLERS.RECORD$ = SPACE$(5) + CALLERS.RECORD$
CALL PRINTIT (CALLERS.RECORD$)
IF LOCAL.USER AND PRINTER THEN _
EXIT SUB
CALLERS.FILE.INDEX = CALLERS.FILE.INDEX + 1
PUT 4,CALLERS.FILE.INDEX
END SUB
' $SUBTITLE: 'PRINTIT - subroutine to print on the local PC's printer'
' $PAGE
'
' SUBROUTINE NAME -- PRINTIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO WRITE TO THE PRINTER
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO WRITE TO THE PRINTER ATTACHED TO THE PC RUNNING
' RBBS-PC AND TOGGLE THE PRINTER SWTICH OFF WHENEVER
' THE PRINTER IS/BECOMES UNAVAILABLE
'
SUB PRINTIT (STRNG$) STATIC
ON ERROR GOTO 65000
13674 IF PRINTER THEN _
LPRINT STRNG$
END SUB
' $SUBTITLE: 'FINDIT - subroutine to find if a file exists'
' $PAGE
'
' SUBROUTINE NAME -- FINDIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF FILE TO FIND
'
' OUTPUT PARAMETERS -- OK TRUE IF FILE EXISTS
' EC ERROR CODE
'
' SUBROUTINE PURPOSE -- DETERMINE IF A FILE EXISTS BY RENAMING IT TO ITSELF
'
SUB FINDIT (FILNAME$) STATIC
ON ERROR GOTO 65000
EC = 0
OK = FALSE
IF TURBO.RBBS THEN _
CALL RBBSFIND (FILNAME$,ZZ%,YY%,MM%,DD%) : _
IF ZZ% = 0 THEN _
OK = TRUE : _
GOTO 20222 _
ELSE EXIT SUB
20221 NAME FILNAME$ AS FILNAME$
IF EC = 53 THEN _
EXIT SUB
20222 CLOSE 2
20223 OPEN FILNAME$ FOR INPUT AS #2
IF EC = 64 OR EC = 76 THEN _
EXIT SUB
OK = TRUE
END SUB
' $SUBTITLE: 'SENDNAME - send FILENAME using EXEC-PC protocol'
' $PAGE
'
' SUBROUTINE NAME -- SENDNAME
'
' INPUT PARAMETERS -- PARAMETER MEANING
' B$() ARRAY OF FILENAME FOR AUTODOWNLOAD
' DWN.INDEX INDEX OF FILENAME TO TRANSFER
'
' OUTPUT PARAMETERS -- ABORT -1 FOR AN ABORTED ATTEMPT
'
' SUBROUTINE PURPOSE -- SEND THE DOWNLOAD FILENAME TO USER DURING AN
' AUTODOWNLOAD.
'
SUB SENDNAME STATIC
'
' *****************************************************************************
' * TRANSFER FILENAME TO USER *
' * PROCESS - Send USER the "ALERT" character sequence -- <ESC>OD *
' * Then this is followed by character-by-character *
' * transmission of the filename with echo. If any of the *
' * characters of the filename are garbled a series of *
' * <CAN> are sent, otherwise an <ACK> is sent at *
' * completion and file transfer begins. *
' *****************************************************************************
'
ON ERROR GOTO 65000
ABORT = FALSE ' RESET ABORT FLAG
ATTEMPTS = 0 ' RESET COUNT FOR # OF TRANS ATTEMPTS
20295 CALL DELAYIT (1) ' ONE SECOND DELAY
20296 Y$ = INPUT$(LOC(3),3) ' CLEAR THE COMM BUFFER OF GARBAGE
20297 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 20296
PRINT#3,ESCAPE$;"OD"; ' SEND "ALERT" STRING
IF ABORT = TRUE THEN _
GOTO 20306
IF SNOOP THEN _
PRINT "Sending FILENAME -- " : _
PRINT RETURN.LINE.FEED$; _
CHR$(9);
CALL DELAYIT (1) ' WAIT 1 SECOND FOR SETUP
'
' SEND ONE CHARACTER AT A TIME
'
A$ = B$(DWN.INDEX) + "=X"
FOR X = 1 TO LEN(A$)
PRINT#3,MID$(A$,X,1); ' SEND 1 CHARACTER
IF ABORT = TRUE THEN _
GOTO 20306
IF SNOOP THEN _
PRINT MID$(A$,X,1); ' DISPLAY IF NEEDED
IF TIMER < 86390! THEN _
DELAY! = TIMER + 10 _
ELSE DELAY! = TIMER - 86400! + 10 ' SET MAXIMUM TIME TO WAIT FOR REPLY
WHILE EOF(3)
IF TIMER > DELAY! THEN _
GOTO 20300 ' IF NO ECHO, CANCEL FILENAME TRANSFER
WEND ' JUMP OUT IF CHARACTER IS RECEIVED
20298 Y$ = INPUT$(LOC(3),3) ' COLLECT CHARACTER(S) USER ECHOED
20299 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 20298
IF MID$(A$,X,1) = Y$ THEN _
GOTO 20305 ' IF CORRECTLY ECHOED, THEN CONTINUE
IF INSTR(Y$,CANCEL$) THEN _
ABORT = TRUE : _
GOTO 20306 ' CHECK FOR USER ABORT
20300 PRINT#3,STRING$(5,24); ' TELL USER THAT FILE NAME IS GARBLED
IF ABORT = TRUE THEN _
GOTO 20306
IF SNOOP THEN _
PRINT "Name Trans Failure" ' DISPLAY FAILURE ON SCREEN
ATTEMPTS = ATTEMPTS + 1 ' INCREMENT COUNTER FOR # OF TRIES
IF ATTEMPTS < 6 THEN _ ' TRY IT FIVE TIMES, THEN GIVE UP
GOTO 20295
PRINT#3,STRING$(50,24); ' GUARANTEE CANCELLATION OF USER
IF ABORT = TRUE THEN _
GOTO 20306
IF SNOOP THEN _
PRINT "ABORTING AUTODOWNLOAD!": _
ABORT = TRUE : _
GOTO 20306
'
20305 NEXT ' LOOP BACK FOR NEXT CHARACTER
'
PRINT#3,ACKNOWLEDGE$; ' WHEN FILENAME SENT, ACKNOWLEDGE
IF SNOOP THEN _ ' AND CONTINUE.
PRINT RETURN.LINE.FEED$ ' CLEAN UP SYSOP'S DISPLAY
'
' COMPLETION OF AUTODOWNLOAD FILENAME TRANSFER
'
20306 END SUB
' $SUBTITLE: 'TESTUSER - interrogate user for AUTO-DOWNLOADING protocol'
' $PAGE
'
' SUBROUTINE NAME -- TESTUSER
'
' INPUT PARAMETERS -- NONE
'
' OUTPUT PARAMETERS -- AUTODOWNLOAD.AVAILABLE -1 IF USER'S COMMUNICATION
' SOFTWARE CAN DO AUTO-
' DOWNLOADING
'
' SUBROUTINE PURPOSE -- SEND THE USER AN <ESCAPE><XON> AND IF RESPONSE
' IS A RECOGNIZED PACKAGE, SET APPROPRIATE FLAG.
'
SUB TESTUSER STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * TEST FOR COMMUNICATIONS USING N,8,1 PROTOCOL AND EXECPC TALK VER 2.0+ *
' * TO SEE IF CALLER CAN USE THE AUTODOWNLOAD FEATURE *
' *****************************************************************************
'
20310 ABORT = FALSE
20311 Y$ = INPUT$(LOC(3),3) ' FLUSH THE COMM BUFFER
20312 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 20311
PRINT#3,ESCAPE$;XON$; ' SEND QUERY STRING TO USER
IF ABORT = TRUE THEN _
GOTO 20315
CALL DELAYIT (2) ' WAIT TWO SECONDS FOR REPLY
20313 Y$=INPUT$(LOC(3),3) ' GET CONTENTS OF COMM BUFFER
20314 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 20313
IF INSTR(Y$,"EXECPC2") THEN _
COM.PROGRAM = 1
IF INSTR(Y$,"PIBTERM") THEN _
COM.PROGRAM = 2
IF INSTR(Y$,"PROCOMM") THEN _
COM.PROGRAM = 3
IF INSTR(Y$,"QMODEM") THEN _
COM.PROGRAM = 4
20315 END SUB
' $SUBTITLE: 'UPCATEC - update of callers log on exiting'
' $PAGE
'
' SUBROUTINE NAME -- UPDATEC
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CALLERS.FILE.INDEX
' FIRST.NAME$
' HHH
' LAST.NAME$
' MMM
' NG$
' SSS
' SYSOP.FIRST.NAME$
' SYSOP.LAST.NAME$
'
' OUTPUT PARAMETERS -- CALLERS.RECORD$
' CALLERS.FILE.INDEX
' SYSOP
'
' SUBROUTINE PURPOSE -- UPDATE THE CALLERS FILE AT LOGOFF SO THAT THE NUMBER
' OF HOURS, MINUTES, AND SECONDS FOR THE SESSION ARE
' RECORDED AS THE LAST 9 CHARACTERS OF THE 64-CHARACTER
' CALLERS FILE RECORD
'
SUB UPDATEC STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * UPDATE CALLERS FILE AT LOGOFF *
' *****************************************************************************
'
43050 FIELD 4,55 AS CALLERS.RECORD$,3 AS HOURS$,3 AS MINUTES$,3 AS SECONDS$
LSET CALLERS.RECORD$ = MID$(NG$,65,55)
LSET HOURS$ = STR$(HHH)
LSET MINUTES$ = STR$(MMM)
LSET SECONDS$ = STR$(SSS)
CALLERS.FILE.INDEX = CALLERS.FILE.INDEX + 1
PUT 4,CALLERS.FILE.INDEX
FIELD 4,64 AS CALLERS.RECORD$
LSET CALLERS.RECORD$ = LEFT$(NG$,64)
CALLERS.FILE.INDEX = CALLERS.FILE.INDEX + 1
PUT 4,CALLERS.FILE.INDEX
43060 LSET CALLERS.RECORD$ = STRING$(64,CHR$(0))
CALLERS.FILE.INDEX = CALLERS.FILE.INDEX + 1
PUT 4
CALLERS.FILE.INDEX = CALLERS.FILE.INDEX + 1
PUT 4
SYSOP = (FIRST.NAME$ = SYSOP.FIRST.NAME$ AND _
LAST.NAME$ = SYSOP.LAST.NAME$)
END SUB
' $SUBTITLE: 'FINDFREE - subroutine to find space on a device'
' $PAGE
'
' SUBROUTINE NAME -- FINDFREE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' Z$ NAME OF FILE TO FIND
'
' OUTPUT PARAMETERS -- FREE.SPACE$ NUMBER OF BYTES FREE
'
' SUBROUTINE PURPOSE -- TO DETERMINE AMOUNT OF FREE SPACE ON A DEVICE
'
SUB FINDFREE STATIC
ON ERROR GOTO 65000
EC = 0
'
' *****************************************************************************
' * GET FREE SPACE ON DISK *
' *****************************************************************************
'
52000 IF TURBO.RBBS THEN _
GOTO 52003
FREE.SPACE$ = ""
CLS
52001 FILES Z$
IF EC = 53 AND Z$ = COMMENTS.FILE$ THEN _
CLOSE 2: _
OPEN "O",2,COMMENTS.FILE$ : _
GOTO 52000
IF EC = 53 AND Z$ = UPLOAD.DIRECTORY$ THEN _
A$ = "Upload directory missing. Tell SYSOP" : _
SUBROUTINE.PARAMETER = 6 : _
CALL TPUT : _
GOTO 52002
FOR X = 1 TO 25
FREE.SPACE$ = FREE.SPACE$ + CHR$(SCREEN (3,X))
NEXT
52002 SUBROUTINE.PARAMETER = 1
CALL LINE25
EXIT SUB
52003 AX% = 0
BX% = 0
CX% = 0
DX% = 0
IF MID$(Z$,2,1) = ":" THEN _
AX% = ASC(Z$) - ASC("A") + 1
CALL RBBSFREE (AX%,BX%,CX%,DX%)
I# = CDBL(AX%) * BX%
I# = I# * CX%
FREE.SPACE$ = STR$(I#) + " bytes free"
END SUB
' $SUBTITLE: 'OPENWORK - subroutine to open RBBS-PC's work file (2)'
' $PAGE
'
' SUBROUTINE NAME -- OPENWORK
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF FILE TO FIND
' SHARE.IT USE DOS' "SHARE" FACILITIES
'
' OUTPUT PARAMETERS -- EC ERROR CODE
'
' SUBROUTINE PURPOSE -- TO OPEN RBBS-PC'S "WORK" FILE (NUMBER 2)
'
SUB OPENWORK (FILNAME$) STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * OPEN RBBS-PC'S "WORK FILE" (I.E. FILE NUMBER 2) FOR INPUT. OPEN IT AS *
' * "SHARED" IF MULTIPLE COPIES OF RBBS-PC WILL BE RUNNING UNDER THE SAME DOS *
' *****************************************************************************
'
58000 CLOSE 2
58010 EC = 0
58020 IF SHARE.IT THEN _
OPEN FILNAME$ FOR INPUT SHARED AS #2 _
ELSE OPEN FILNAME$ FOR INPUT AS #2
IF EC = 52 THEN _
GOTO 58010
58030 END SUB
' $SUBTITLE: 'OPENFMS - subroutine to open the FMS directory'
' $PAGE
'
' SUBROUTINE NAME -- OPENFMS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SHARE.IT DOS SHARING FLAG
' FMS.DIRECTORY$ NAME OF FMS DIRECTORY
'
' OUTPUT PARAMETERS -- LAST.REC NUMBER OF THE LAST
' RECORD IN THE FILE
'
' SUBROUTINE PURPOSE -- TO OPEN THE UPLOAD DIRECTORY AS A RANDOM FILE AND FIND
' THE NUMBER OF THE LAST RECORD IN THE FILE.
'
SUB OPENFMS (LAST.REC) STATIC
58190 ON ERROR GOTO 65000
FLEN = 38+MAX.DESC.LEN
CLOSE 2
IF SHARE.IT THEN _
OPEN FMS.DIRECTORY$ FOR RANDOM SHARED AS #2 LEN=FLEN _
ELSE OPEN "R",2,FMS.DIRECTORY$,FLEN
IF EC > 0 THEN _
EC = 0 : _
GOTO 58192
LAST.REC = LOF(2)/FLEN
EXIT SUB
58192 LAST.REC = 0
END SUB
' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
' $PAGE
'
' SUBROUTINE NAME -- ASKUSERS (Written by Jon Martin)
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF THE FILE CONTAINING THE
' SCRIPT TO BE USED WHEN ASKING
' THE USER QUESTIONS.
' ACTIVE.USER.NAME$ NAME OF THE CURRENT USER
' USER.SECURITY.LEVEL USER'S SECURITY
' UPPER.CASE SET IF USER NEEDS UPPERCASE
'
' OUTPUT PARAMETERS -- WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
' FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
' FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
' BE USED.
' USER.SECURITY.LEVEL CAN BE RAISED OR LOWERED
'
' SUBROUTINE PURPOSE -- PROVIDES A SOPHISTCATED, SCRIPT DRIVEN MECHANISM BY
' WHICH A SYSOP CAN SOLICIT INFORMATION FROM NEW USERS
' (VIA A SCRIPT THAT REQUESTS REGISTRATION INFORMATION
' AND WHICH CAN UPPER OR LOWER HIS DEFAULT SECURITY
' LEVEL BASED ON THE RESPONSES) OR ASK A QUESTIONS OF
' WHEN THE USER LOGS OFF. THE FORMER OCCURS IF THE
' FILE "RBBS-REG.DEF" CONTAINING THE REGISTRATION
' SCRIPT EXISTS ON THE SAME DRIVE AS THE "WELCOME".
' THE LATER EXISTS IF THE FILE "EPILOG.DEF" EXISTS ON
' THE SAME DRIVE AS THE "WELCOME".
'
SUB ASKUSERS STATIC
ON ERROR GOTO 65000
'
' *****************************************************************************
' * LOAD SCRIPT CONTAING THE QUESTIONS INTO THE A$ DIMENSION *
' *****************************************************************************
'
64005 CHAT.AVAILABLE = FALSE
CALL OPENWORK (FILE.NAME$)
INPUT #2,APPEND.FILE.NAME$,MAXIMUM.SECURITY.LEVEL
'
' *****************************************************************************
' * THE FIRST RECORD OF THE SCRIPT FILE CONTAINS TWO PARAMETERS: *
' * 1. THE NAME OF THE FILE TO APPEND THE ANSWERS TO. *
' * 2. THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY *
' *****************************************************************************
SCRIPT.INDEX = 1
A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
" " + _
DATE$ + _
" " + _
TIME$
64010 IF EOF(2) OR SCRIPT.INDEX > 256 THEN _
GOTO 64100
SCRIPT.INDEX = SCRIPT.INDEX + 1
LINE INPUT #2,A$(SCRIPT.INDEX)
IF UPPER.CASE THEN _
CALL ALLCAPSD (A$(),SCRIPT.INDEX)
IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
A$(SCRIPT.INDEX) = "!"
GOTO 64010
'
' *****************************************************************************
' * PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS: *
' * *
' * FIRST COLUMN MEANING *
' * : THIS LINE IS A LABEL THAT MAY BE BRANCHED TO *
' * ! THIS MEANS THIS IS AN ANSWER *
' * > THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS *
' * * THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER *
' * ? THIS MEANS THIS IS A QUESTION FOR THE USER *
' * = THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA *
' * - THIS MEANS TO LOWER THE USER'S SECURITY LEVEL *
' * + THIS MEANS TO RAISE THE USER'S SECURITY LEVEL *
' * @ THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT *
' *****************************************************************************
'
64100 SCRIPT.MAX = SCRIPT.INDEX
SCRIPT.INDEX = 1
64110 CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64115
SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
GOTO 64400
IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _ ' LABEL
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _ ' ANSWER
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _ ' ABORT
GOTO 64510
IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _ ' GOTO
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),2) : _
GOSUB 64200 : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _ ' MESSAGE
A$ = MID$(A$(SCRIPT.INDEX),2) : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
64113 IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _ ' QUESTION
A$ = MID$(A$(SCRIPT.INDEX),2) : _
SUBROUTINE.PARAMETER = 1 : _
CALL TGET : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE IF Q = 0 THEN _
GOTO 64113 _
ELSE A$(SCRIPT.INDEX + 1) = "!" + B$(1) : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _ ' NUMERIC
GOSUB 64350 : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _ ' DECISION
GOSUB 64300 : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _ ' LOWER
ADJUSTED.SECURITY = -1 : _
USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _
VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _ ' RAISE
IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _
<= MAXIMUM.SECURITY.LEVEL THEN _
ADJUSTED.SECURITY = -1 : _
USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _
VAL(MID$(A$(SCRIPT.INDEX),2,5))
IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _
GOTO 64110
A$ = A$(SCRIPT.INDEX) ' INVALID
SUBROUTINE.PARAMETER = 5
CALL TPUT
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510
A$ = "Column 1 must be : * ? = + - > @"
SUBROUTINE.PARAMETER = 5
CALL TPUT
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510
64115 GOTO 64510
'
' *****************************************************************************
' * SEARCH FOR GOTO LABEL *
' *****************************************************************************
'
64200 SCRIPT.INDEX = 1
64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
A$ = BRANCH.LABEL$ + " not found!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 THEN _
RETURN _
ELSE GOTO 64115
IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
GOTO 64210
IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
GOTO 64210
RETURN
'
' *****************************************************************************
' * DETERMINE BRANCH LOGIC *
' *****************************************************************************
'
64300 CURRENT.EQUALS = 1
Z$ = RIGHT$(A$(SCRIPT.INDEX - 1),1)
CALL ALLCAPS(Z$)
64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
IF NEXT.EQUALS = 0 THEN _
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
GOTO 64320
IF Z$ <> _
MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS +1,1) THEN _
CURRENT.EQUALS = NEXT.EQUALS : _
GOTO 64310
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS+2))
64320 GOSUB 64200
RETURN
'
' *****************************************************************************
' * DETERMINE NUMERIC BRANCH LOGIC *
' *****************************************************************************
'
64350 CURRENT.EQUALS = 1
64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
IF NEXT.EQUALS = 0 THEN _
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
GOTO 64380
NUMERIC = TRUE
LOOP.INDEX = 2
WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
GOTO 64370
NUMERIC = FALSE
64370 LOOP.INDEX = LOOP.INDEX + 1
WEND
IF NOT NUMERIC THEN _
CURRENT.EQUALS = NEXT.EQUALS : _
GOTO 64360
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS+2))
64380 GOSUB 64200
RETURN
'
' *****************************************************************************
' * WRITE RESPONSES TO DESIGNATED FILE *
' *****************************************************************************
'
64400 SCRIPT.INDEX = 0
EC = 0
SUBROUTINE.PARAMETER = 9
FILE.NAME$ = APPEND.FILE.NAME$
EN$ = APPEND.FILE.NAME$
CALL FILELOCK
CLOSE 2
IF SHARE.IT THEN _
OPEN FILE.NAME$ FOR APPEND SHARED AS #2 _
ELSE OPEN FILE.NAME$ FOR APPEND AS #2
IF EC <> 0 THEN _
A$ = "Fatal Error in script!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
GOTO 64500
64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
GOTO 64500
IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
GOTO 64410
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
LEN(A$(SCRIPT.INDEX)) < 2 THEN _
GOTO 64410
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
PRINT #2,QUESTION.SAVE$ : _
PRINT #2,MID$(A$(SCRIPT.INDEX),2)
IF SCRIPT.INDEX = 1 THEN _
PRINT #2,A$(SCRIPT.INDEX)
IF EC <> 0 THEN _
A$ = "Unrecoverable failure in script!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
GOTO 64500
GOTO 64410
64500 CLOSE 2
SUBROUTINE.PARAMETER = 10
CALL FILELOCK
CALL CARRIER
64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$)>0)
END SUB
' $SUBTITLE: 'Error Handling for separately compiled subroutines'
' $PAGE
'
' *****************************************************************************
' * Error handling for the separately compiled subroutines of RBBS-PC *
' *****************************************************************************
'
65000 IF DEBUG THEN _
A$ = "RBBS-SUB1 DEBUG Error Trap Entry ERL=" + _
STR$(ERL) + _
" ERR=" + _
STR$(ERR) : _
IF PRINTER THEN _
LPRINT A$ _
ELSE PRINT A$
EC = ERR
'
' OPEN CONFIG FILE
'
IF ERL = 117 THEN _
CLS : _
PRINT CONFIG.FILENAME$;" not found! Run CONFIG!" : _ ' cpc151a4
SYSTEM
'
' ANSWERIT ERROR HANDLING
'
IF ERL = 210 THEN _
RESUME NEXT
IF ERL = (276 OR 324) AND ERR = 57 THEN _
RESUME NEXT
IF ERL = (277 OR 290 OR 325) AND ERR = 57 THEN _
RESUME
IF ERL = 324 AND ERR = 69 THEN _
SUBROUTINE.PARAMETER = 5 : _
RESUME NEXT
IF ERL => 201 AND ERL =< 326 THEN _
RESUME
'
' TPUT ERROR HANDLING
'
IF ERL = 1420 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 1420 AND ERR = 69 THEN _
SUBROUTINE.PARAMETER = -1 : _
RESUME NEXT
IF ERL = 1421 AND ERR = 57 THEN _
RESUME
IF ERL = 1421 AND ERR = 69 THEN _
SUBROUTINE.PARAMETER = -1 : _
RESUME NEXT
IF ERL => 1398 AND ERL =< 1475 THEN _
RESUME
'
' OPENRESEQ ERROR HANDLING
'
IF ERL = 1481 THEN _
EC = ERR : _
RESUME NEXT
IF ERL = 1496 THEN _
EC = 1496 :_
RESUME NEXT
'
' TGET ERROR HANDLING
'
IF ERL = 1540 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 1541 AND ERR = 57 THEN _
RESUME
IF ERL = 1541 AND ERR = 69 THEN _
SUBROUTINE.PARAMETER = -1 : _
RESUME NEXT
IF ERL = 1542 AND ERR = 5 THEN _
Y$ = " " : _
RESUME
IF ERL => 1500 AND ERL =< 1635 THEN _
RESUME
'
' LINEEDIT ERROR HANDLING
'
IF ERL = 3737 AND ERR = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
RESUME
'
' BAUD450 ERROR HANDLING
'
IF ERL = 5536 AND ERR = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER)
IF ERL = 5536 THEN _
RESUME NEXT
'
' OPENUSER ERROR HANDLING
'
IF ERL = 9400 AND ERR = 75 AND SHARE.IT THEN _
CALL DELAYIT (30) : _
RESUME
'
' FINDUSER ERROR HANDLING
'
IF ERL = 12610 THEN _
RESUME NEXT
'
' PRINTER ERROR HANDLING
'
IF ERL = 13674 THEN _
PRINTER = FALSE : _
RESUME
'
' FINDIT ERROR HANDLING
'
IF ERL = 20221 THEN _
RESUME NEXT
IF ERL = 20223 AND EC = 58 THEN _
EC = 64 : _
RESUME NEXT
IF ERL = 20223 AND EC = 76 THEN _
PRINT "Bad path. File name is ";FILNAME$:_
EC = 76 :_
RESUME NEXT
IF ERL => 20221 AND ERL =< 20223 THEN _
RESUME
'
' SENDNAME ERROR HANDLING
'
IF ERL = (20296 OR 20298) AND ERR = 57 THEN _
RESUME NEXT
IF ERL = (20297 OR 20299) AND ERR = 57 THEN _
RESUME
IF ERL => 20295 AND ERL =< 20306 THEN _
ABORT = TRUE : _
RESUME NEXT
'
' TESTUSER ERROR HANDLING
'
IF ERL = (20311 OR 20313) AND ERR = 57 THEN _
RESUME NEXT
IF ERL = (20312 OR 20314) AND ERR = 57 THEN _
RESUME
IF ERL => 20310 AND ERL =< 20315 THEN _
ABORT = TRUE : _
RESUME NEXT
'
' UPDATEC ERROR HANDLING
'
IF ERL => 43050 AND ERL =< 43060 AND ERR = 61 THEN _
A$ = "* Disk full - terminating *" : _
SUBROUTINE.PARAMETER =2 : _
CALL TPUT : _
IF DISKFULL.GO.OFFLINE THEN _
CLOSE 3 : _
OPEN COM.PORT$ + ":" + MODEM.INIT.BAUD$ + ",N,8,1,RS,CD,DS" AS #3 : _
CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$) : _
SYSTEM _
ELSE SYSTEM
'
' FINDFREE ERROR HANDLING
'
IF ERL => 52000 AND ERL =< 52003 THEN _
RESUME NEXT
'
' OPENWORK ERROR HANDLING
'
IF ERL => 58000 AND ERL =< 58030 THEN _
RESUME NEXT
'
' OPENUPL ERROR HANDLING
'
IF ERL = 58190 THEN _
RESUME NEXT
'
' ASKUSER ERROR HANDLING
'
IF ERL = 64400 THEN _
RESUME NEXT
IF ERL = 64410 THEN _
RESUME NEXT
'
' CATCH ALL OTHER ERRORS
'
A$ = "RBBS-SUB1 Untrapped Error" + STR$(ERR) + " in line" + STR$(ERL)
CALL QTPUT (A$,1)
CALL UPDTCALR (A$,2)
RESUME NEXT